home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / debug / trace.l < prev    next >
Text File  |  1988-09-12  |  14KB  |  386 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; Trace works by substituting trace functions for the display-write/input functions.
  20. ;; The trace functions maintain a database of requests sent to the server in the
  21. ;; trace-history display property.  This is an alist of (id . byte-vector) where
  22. ;; id is the request number for writes, :reply for replies, :event for events and
  23. ;; :error for errors.  The alist is kept in reverse order (most recent first)
  24.  
  25. ;;; Created 09/14/87 by LaMott G. OREN
  26.  
  27. (in-package "XLIB" :use '("LISP"))
  28.  
  29. (export '(trace-display
  30.        untrace-display
  31.        display-trace
  32.        describe-request
  33.        describe-event
  34.        describe-reply
  35.        describe-error
  36.        describe-trace))
  37.  
  38. (defun trace-display (display)
  39.   "Start a trace on DISPLAY.
  40.  If display is already being traced, this discards previous history.
  41.  See display-trace and describe-trace."  
  42.   (declare (type display display))
  43.   (unless (getf (display-plist display) 'write-function)
  44.     (let ((write-function (display-write-function display))
  45.       (input-function (display-input-function display)))
  46.       ;; Save origional write/input functions so we can untrace
  47.       (setf (getf (display-plist display) 'write-function) write-function)
  48.       (setf (getf (display-plist display) 'input-function) input-function)
  49.       ;; Set new write/input functions that will record what's sent to the server
  50.       (setf (display-write-function display)
  51.         #'(lambda (vector display start end)
  52.         (trace-write-hook vector display start end)
  53.         (funcall write-function vector display start end)))
  54.       (setf (display-input-function display)
  55.         #'(lambda (display vector start end timeout)
  56.         (let ((result (funcall input-function display vector start end timeout)))
  57.           (unless result
  58.             (trace-read-hook display vector start end))
  59.           result)))))
  60.   (setf (display-trace-history display) nil)
  61.   t)
  62.  
  63. (defun untrace-display (display)
  64.   "Stop tracing DISPLAY."
  65.   (declare (type display display))
  66.   (let ((write-function (getf (display-plist display) 'write-function))
  67.     (input-function (getf (display-plist display) 'input-function)))
  68.     (when write-function (setf (display-write-function display) write-function))
  69.     (when input-function (setf (display-input-function display) input-function))
  70.     (remf (display-plist display) 'write-function)
  71.     (remf (display-plist display) 'input-function)
  72.     (setf (display-trace-history display) nil)))
  73.  
  74.  
  75. (defun byte-ref16 (vector index)
  76.   #+clx-little-endian
  77.    (logior (the card16
  78.         (ash (the card8 (aref vector (index+ index 1))) 8))
  79.        (the card8
  80.         (aref vector index)))
  81.   #-clx-little-endian
  82.    (logior (the card16
  83.         (ash (the card8 (aref vector index))) 8)
  84.        (the card8
  85.         (aref vector (index+ index 1)))))
  86.  
  87. (defun byte-ref32 (a i)
  88.   (declare (type buffer-bytes a)
  89.        (type array-index i))
  90.   (declare-values card32)
  91.   (declare-buffun)
  92.   #+clx-little-endian
  93.   (the card32
  94.        (logior (the card32
  95.             (ash (the card8 (aref a (index+ i 3))) 24))
  96.            (the card29
  97.             (ash (the card8 (aref a (index+ i 2))) 16))
  98.            (the card16
  99.             (ash (the card8 (aref a (index+ i 1))) 8))
  100.            (the card8
  101.             (aref a i))))
  102.   #-clx-little-endian
  103.   (the card32
  104.        (logior (the card32
  105.             (ash (the card8 (aref a i)) 24))
  106.            (the card29
  107.             (ash (the card8 (aref a (index+ i 1))) 16))
  108.            (the card16
  109.             (ash (the card8 (aref a (index+ i 2))) 8))
  110.            (the card8
  111.             (aref a (index+ i 3))))))
  112.  
  113. (defun trace-write-hook (vector display start end)
  114.   ;; Called only by buffer-flush.  Start should always be 0
  115.   (unless (zerop start) (format *debug-io* "write-called with non-zero start: ~d" start))
  116.   (let* ((history (display-trace-history display))
  117.      (request-number (display-request-number display))
  118.      (last-history (car history)))
  119.     ;; There may be several requests in the buffer, and the last one may be incomplete.
  120.     ;; The first one may be the completion of a previous request.
  121.     ;; We can detect incomplete requests by comparing the expected length of the last request
  122.     ;; with the actual length.
  123.     (when (and last-history (numberp (car last-history)))
  124.       (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2)))
  125.          (append-length (min (- last-length (length (cdr last-history)))
  126.                  (- end start))))
  127.     (when (plusp append-length)
  128.       ;; Last history incomplete - append to last
  129.       (setf (cdr last-history) (concatenate '(vector card8) (cdr last-history)
  130.                           (subseq vector start (+ start append-length))))
  131.       (index-incf start append-length))))
  132.     ;; Copy new requests into the history
  133.     (do* ((new-history nil)
  134.       (i start (+ i length))
  135.       request
  136.       length)
  137.      ((>= i end)
  138.       ;; add in sequence numbers
  139.       (dolist (entry new-history)
  140.         (setf (car entry) request-number)
  141.         (decf request-number))
  142.       (setf (display-trace-history display)
  143.         (nconc new-history history)))
  144.       (setq request (aref vector i))
  145.       (setq length (index* 4 (byte-ref16 vector (+ i 2))))
  146.       (when (zerop length)
  147.     (si:fsignal "Zero length in buffer")
  148.     (return nil))
  149.       (push (cons 0 (subseq vector i (min (+ i length) end))) new-history)
  150.       (when (zerop request)
  151.     (si:fsignal "Zero request in buffer")
  152.     (return nil))
  153.       )))
  154.  
  155. (defun trace-read-hook (display vector start end)
  156.   ;; Reading is done with an initial length of 32 (with start = 0)
  157.   ;; This may be followed by several other reads for long replies.
  158.   (let* ((history (display-trace-history display))
  159.      (last-history (car history))
  160.      (length (- end start)))
  161.     (when (and history (eq (car last-history) :reply))
  162.       (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4))))
  163.          (append-length (min (- last-length (length (cdr last-history)))
  164.                  (- end start))))
  165.     (when (plusp append-length)
  166.       (setf (cdr last-history) (concatenate '(vector card8) (cdr last-history)
  167.                         (subseq vector start (+ start append-length))))
  168.       (index-incf start append-length)
  169.       (index-decf length append-length))))
  170.     
  171.     ;; Copy new requests into the history
  172.     (when (plusp length)
  173.       (push (cons (case (aref vector start)
  174.             (0 :error)
  175.             (1 :reply)
  176.             (otherwise :event))
  177.           (subseq vector start (+ start length)))
  178.         (display-trace-history display)))))
  179.  
  180. (defun display-trace (display &optional length)
  181.   "Display the trace history for DISPLAY.
  182.  The default is to show ALL history entries.
  183.  When the LENGTH parameter is used, only the last LENGTH entries are
  184.  displayed."
  185.   (declare (type display display))
  186.   (dolist (hist (reverse (subseq (display-trace-history display)
  187.                  0 length)))
  188.     (let* ((id (car hist))
  189.        (vector (cdr hist))
  190.        (length (length vector))
  191.        (request (aref vector 0)))
  192.       (format t "~%~5d " id)
  193.       (case id
  194.     (:error
  195.      (trace-error-print display vector))
  196.     (:event
  197.      (format t "~a (~d) Sequence ~d"
  198.          (if (< request (length *event-key-vector*))
  199.              (aref *event-key-vector* request)
  200.            "Unknown")
  201.          request
  202.          (byte-ref16 vector 2)))
  203.     (:reply
  204.      (format t "To ~d length ~d"
  205.          (byte-ref16 vector 2) length)
  206.      (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  207.        (unless (= length actual-length)
  208.          (format t " Should be ~d **************" actual-length))))
  209.     (otherwise
  210.      (format t "~a (~d) length ~d"
  211.          (request-name request) request length))))))
  212.  
  213. (defun find-trace (display type sequence &optional (number 0))
  214.   (dolist (history (display-trace-history display))
  215.     (when (and (symbolp (car history))
  216.            (= (aref (cdr history) 0) type)
  217.            (= (byte-ref16 (cdr history) 2) sequence)
  218.            (minusp (decf number)))
  219.       (return (cdr history)))))
  220.  
  221. (defun describe-error (display sequence)
  222.   "D
  223.   (LET ((VECTOR (find-trace display 0 sequence)))
  224.     (IF vector
  225.     (PROGN
  226.       (TERPRI)
  227.       (trace-error-print display vector))
  228.       (FORMAT t "Error with sequence ~d not found." sequence))))
  229.  
  230. (DEFUN trace-error-print (display VECTOR &optional (STREAM *standard-output*))
  231.   (let ((event (allocate-event)))
  232.     ;; Copy into event from reply buffer
  233.     (buffer-replace (reply-ibuf8 event)
  234.             vector
  235.             0
  236.             *replysize*)
  237.     (reading-event (event)
  238.       (let* ((type (read-card8 0))
  239.          (error-code (read-card8 1))
  240.          (sequence (read-card16 2))
  241.          (resource-id (read-card32 4))
  242.          (minor-code (read-card16 8))
  243.          (major-code (read-card8 10))
  244.          (current-sequence (ldb (byte 16 0) (buffer-request-number display)))
  245.          (error-key
  246.            (if (< error-code (length *xerror-vector*))
  247.            (aref *xerror-vector* error-code)
  248.          'unknown-error))
  249.          (params
  250.            (case error-key
  251.          ((colormap-error cursor-error drawable-error font-error gcontext-error
  252.                   id-choice-error pixmap-error window-error)
  253.           (list :resource-id resource-id))
  254.          (atom-error 
  255.           (list :atom-id resource-id))
  256.          (value-error
  257.           (list :value resource-id))
  258.          (unknown-error
  259.           ;; Prevent errors when handler is a sequence
  260.           (setq error-code 0)
  261.           (list :error-code error-code)))))
  262.     type
  263.     (LET ((condition 
  264.         (APPLY #+lispm #'si:MAKE-CONDITION
  265.                #-lispm #'make-condition
  266.                error-key
  267.                :error-key error-key
  268.                :display display
  269.                :major major-code
  270.                :minor minor-code
  271.                :sequence sequence
  272.                :current-sequence current-sequence
  273.                params)))
  274.       (PRINC condition stream)
  275.       (deallocate-event event)
  276.       condition)))))
  277.  
  278. (DEFUN describe-request (display sequence)
  279.   "Describe the request with sequence number SEQUENCE"
  280.   #+ti (si:load-if "clx:debug;describe")
  281.   (LET ((request (ASSOC sequence (display-trace-history display))))
  282.     (IF (NULL request)
  283.     (FORMAT t "~%Request number ~d not found in trace history" sequence)
  284.       (let* ((VECTOR (CDR request))
  285.          (len (LENGTH vector))
  286.          (hist (make-reply-buffer len)))
  287.     (buffer-replace (reply-ibuf8 hist) vector 0 len)
  288.     (print-history-description hist)))))
  289.  
  290. (DEFUN describe-reply (display sequence)
  291.   "Print the reply to request SEQUENCE.
  292.  (The current implementation doesn't print very pretty)"
  293.   (LET ((VECTOR (find-trace display 1 sequence))
  294.     (*print-array* t))
  295.     (IF vector
  296.     (PRINT vector)
  297.       (FORMAT T "~%Reply not found"))))
  298.  
  299. (DEFUN event-number (name)
  300.   (IF (AND (TYPEP name '(integer 0 63))
  301.        (AREF *event-key-vector* name))
  302.       name
  303.     (POSITION (STRING name) *event-key-vector* :test #'EQUALP :key #'STRING)))
  304.  
  305. (DEFUN describe-event (display name sequence)
  306.   "Describe the event with event-name NAME and sequence number SEQUENCE."
  307.   (DECLARE (type display display)
  308.        (type (OR stringable (integer 0 63)) name)
  309.        (type (integer 0) sequence))
  310.   (LET* ((number (event-number name))
  311.      (vector (AND number (find-trace display number sequence))))
  312.     (IF (NOT number)
  313.     (FORMAT T "~%~s isn't an event name" name)
  314.       (IF (NOT vector)
  315.       (FORMAT T "~%Event ~s not found"
  316.           (AREF *event-key-vector* number))
  317.     (trace-event-print display vector)))))
  318.  
  319. (DEFUN trace-event-print (display vector)
  320.   (let* ((event (allocate-event))
  321.      (event-code (LDB (BYTE 7 0) (AREF vector 0)))
  322.      (event-decoder (aref *event-handler-vector* event-code)))
  323.     ;; Copy into event from reply buffer
  324.     (SETF (event-code event) event-code)
  325.     (buffer-replace (reply-ibuf8 event)
  326.             vector
  327.             0
  328.             *replysize*)
  329.     (PROG1 (funcall event-decoder display event
  330.             #'(lambda (&rest args &key send-event-p &allow-other-keys)
  331.             (SETQ args (COPY-LIST args))
  332.             (REMF args :display)
  333.             (REMF args :event-code)
  334.             (UNLESS send-event-p (REMF args :send-event-p))
  335.             args))
  336.        (deallocate-event event))))
  337.  
  338. (defun describe-trace (display &optional length)
  339.   "Display the trace history for DISPLAY.
  340.  The default is to show ALL history entries.
  341.  When the LENGTH parameter is used, only the last LENGTH entries are
  342.  displayed."
  343.   (DECLARE (type display display))
  344.   #+ti (si:load-if "clx:debug;describe")
  345.   (DOLIST (hist (REVERSE (SUBSEQ (display-trace-history display)
  346.                  0 length)))
  347.     (LET* ((id (CAR hist))
  348.        (VECTOR (CDR hist))
  349.        (LENGTH (LENGTH vector)))
  350.       (format t "~%~5d " id)
  351.       (CASE id
  352.     (:error
  353.      (trace-error-print display vector))
  354.     (:event
  355.      (LET ((event (trace-event-print display vector)))
  356.        (WHEN event (FORMAT t "~{ ~s~}" event))))
  357.     (:reply
  358.      (FORMAT t "To ~d length ~d"
  359.          (byte-ref16 vector 2) length)
  360.      (LET ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  361.        (UNLESS (= length actual-length)
  362.          (FORMAT t " Should be ~d **************" actual-length)))
  363.      (LET ((*print-array* t)
  364.            (*print-base* 16.))
  365.        (PRINC " ")
  366.        (PRINC vector)))
  367.     (otherwise
  368.       (let* ((len (LENGTH vector))
  369.          (hist (make-reply-buffer len)))
  370.         (buffer-replace (reply-ibuf8 hist) vector 0 len)
  371.         (print-history-description hist)))))))
  372.  
  373. ;; End of file
  374. al-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  375.        (unless (= length actual-length)
  376.          (format t " Should be ~d **************" actual-length)))
  377.      (let ((*print-array* t)
  378.            (*print-base* 16.))
  379.        (princ " ")
  380.        (princ vector)))
  381.     (otherwise
  382.       (let* ((len (length vector))
  383.          (hist (make-reply-buffer len)))
  384.         (buffer-replace (reply-ibuf8 hist) vector 0 len)
  385.         (print-history-description hist)))))))
  386.